Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume13 / gmcalc / part03 < prev next >

Wrap

Text File | 1990-06-05 | 57.7 KB | 1,780 lines

Newsgroups: comp.sources.misc From: daveg@csvax.caltech.edu (David Gillespie) Subject: v13i029: Emacs Calculator 1.01, part 03/19 Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 13, Issue 29 Submitted-by: daveg@csvax.caltech.edu (David Gillespie) Archive-name: gmcalc/part03 ---- Cut Here and unpack ---- #!/bin/sh # this is part 3 of a multipart archive # do not concatenate these parts, unpack them in order with /bin/sh # file calc.el continued # CurArch=3 if test ! -r s2_seq_.tmp then echo "Please unpack part 1 first!" exit 1; fi ( read Scheck if test "$Scheck" != $CurArch then echo "Please unpack part $Scheck next!" exit 1; else exit 0; fi ) < s2_seq_.tmp || exit 1 echo "x - Continuing file calc.el" sed 's/^X//' << 'SHAR_EOF' >> calc.el X 0))) X (math-make-float (math-quotient (math-scale-int (nth 1 a) ldiff) (nth 1 b)) X (- (- (nth 2 a) (nth 2 b)) ldiff))) X) X X(defun math-inv (m) X (if (Math-vectorp m) X (progn X (calc-extensions) X (if (math-square-matrixp m) X (or (math-with-extra-prec 2 (math-matrix-inv-raw m)) X (math-reject-arg m "Singular matrix")) X (math-reject-arg m 'square-matrixp))) X (math-div 1 m)) X) X(fset 'calcFunc-inv (symbol-function 'math-inv)) X X X(defmacro math-working (msg arg) ; [Public] X (` (if (eq calc-display-working-message 'lots) X (progn X (calc-set-command-flag 'clear-message) X (message "Working... %s = %s" X (, msg) X (math-showing-full-precision X (math-format-number (, arg))))))) X) X X X;;; Compute A modulo B, defined in terms of truncation toward minus infinity. X(defun math-mod (a b) ; [R R R] [Public] X (cond ((Math-zerop a) a) X ((Math-zerop b) X (math-reject-arg a "Division by zero")) X ((and (Math-natnump a) (Math-natnump b)) X (math-imod a b)) X ((and (Math-anglep a) (Math-anglep b)) X (math-sub a (math-mul (math-floor (math-div a b)) b))) X ((and (eq (car-safe a) 'mod) (Math-realp b) (math-posp b)) X (math-make-mod (nth 1 a) b)) X ((and (eq (car-safe a) 'intv) (math-constp a) (math-posp b)) X (math-mod-intv a b)) X (t X (if (Math-anglep a) X (calc-record-why 'anglep b) X (calc-record-why 'anglep a)) X (list '% a b))) X) X(defun calcFunc-mod (a b) X (math-normalize (list '% a b)) X) X X X;;; Compute the greatest common divisor of A and B. [I I I] [Public] X(defun math-gcd (a b) X (cond X ((not (or (consp a) (consp b))) X (if (< a 0) (setq a (- a))) X (if (< b 0) (setq b (- b))) X (let (c) X (if (< a b) X (setq c b b a a c)) X (while (> b 0) X (setq c b X b (% a b) X a c)) X a)) X ((Math-looks-negp a) (math-gcd (math-neg a) b)) X ((Math-looks-negp b) (math-gcd a (math-neg b))) X ((eq a 0) b) X ((eq b 0) a) X ((not (Math-integerp a)) X (if (Math-messy-integerp a) X (math-gcd (math-trunc a) b) X (calc-record-why 'integerp a) X (list 'calcFunc-gcd a b))) X ((not (Math-integerp b)) X (if (Math-messy-integerp b) X (math-gcd a (math-trunc b)) X (calc-record-why 'integerp b) X (list 'calcFunc-gcd a b))) X (t X (let (c) X (if (Math-natnum-lessp a b) X (setq c b b a a c)) X (while (and (consp a) (not (eq b 0))) X (setq c b X b (math-imod a b) X a c)) X (while (> b 0) X (setq c b X b (% a b) X a c)) X a))) X) X(fset 'calcFunc-gcd (symbol-function 'math-gcd)) X X X X;;; General exponentiation. X X(defun math-pow (a b) ; [O O N] [Public] X (cond ((Math-zerop a) X (if (math-zerop b) X (math-reject-arg (list '^ a b) "Indeterminate form") X (if (math-floatp b) (math-float a) a))) X ((or (eq a 1) (eq b 1)) a) X ((or (equal a '(float 1 0)) (equal b '(float 1 0))) a) X ((Math-zerop b) X (if (eq (car-safe a) 'mod) X (math-make-mod 1 (nth 2 a)) X (if (or (math-floatp a) (math-floatp b)) X '(float 1 0) 1))) X ((and (Math-integerp b) (math-numvecp a)) X (math-with-extra-prec 2 X (math-ipow a b))) X (t X (calc-extensions) X (math-pow-fancy a b))) X) X(defun calcFunc-pow (a b) X (math-normalize (list '^ a b)) X) X X(defun math-ipow (a n) ; [O O I] [Public] X (cond ((Math-integer-negp n) X (math-ipow (math-div 1 a) (Math-integer-neg n))) X ((not (consp n)) X (if (and (Math-ratp a) (> n 20)) X (math-iipow-show a n) X (math-iipow a n))) X ((math-evenp n) X (math-ipow (math-sqr a) (math-div2 n))) X (t X (math-mul a (math-ipow (math-sqr a) X (math-div2 (math-add n -1)))))) X) X X(defun math-iipow (a n) ; [O O S] X (cond ((= n 0) 1) X ((= n 1) a) X ((= (% n 2) 0) (math-iipow (math-sqr a) (/ n 2))) X (t (math-mul a (math-iipow (math-sqr a) (/ n 2))))) X) X X(defun math-iipow-show (a n) ; [O O S] X (math-working "pow" a) X (let ((val (cond X ((= n 0) 1) X ((= n 1) a) X ((= (% n 2) 0) (math-iipow-show (math-sqr a) (/ n 2))) X (t (math-mul a (math-iipow-show (math-sqr a) (/ n 2))))))) X (math-working "pow" val) X val) X) X X X X X X;;; Format the number A as a string. [X N; X Z] [Public] X;;; Target line-width is W. X(defun math-format-stack-value (a &optional w) X (or w (setq w (calc-window-width))) X (let ((c (cond ((null a) "<nil>") X ((eq calc-display-raw t) (format "%s" a)) X ((stringp a) a) X ((eq a 'top-of-stack) ".") X ((and (math-scalarp a) X (memq calc-language '(nil flat unform))) X (math-format-number a)) X (t (calc-extensions) X (math-compose-expr a 0)))) X s ww) X (if (and calc-display-just X (< (setq ww (if (stringp c) X (length c) X (math-comp-width c))) w)) X (setq c (math-comp-concat X (make-string (if (eq calc-display-just 'center) X (/ (- w ww) 2) X (- w ww)) 32) X c)) X (if calc-line-numbering X (setq c (math-comp-concat X (if (eq calc-language 'big) "1: " " ") c)))) X (let ((s (if (stringp c) X (if calc-display-raw X (prin1-to-string c) X c) X (math-composition-to-string c w)))) X (if calc-language-output-filter X (setq s (funcall calc-language-output-filter s))) X (if (eq calc-language 'big) X (concat s "\n") X (if calc-line-numbering X (progn X (aset s 0 ?1) X (aset s 1 ?:))) X s))) X) X X(defun math-format-value (a &optional w) X (if (and (math-scalarp a) X (memq calc-language '(nil flat unform))) X (math-format-number a) X (calc-extensions) X (math-composition-to-string (math-compose-expr a 0) w)) X) X X(defun calc-window-width () X (1- (window-width (get-buffer-window (current-buffer)))) X) X X(defun math-comp-concat (c1 c2) X (if (and (stringp c1) (stringp c2)) X (concat c1 c2) X (list 'horiz c1 c2)) X) X X X X;;; Format an expression as a one-line string suitable for re-reading. X X(defun math-format-flat-expr (a prec) X (cond X ((or (not (or (consp a) (integerp a))) X (eq calc-display-raw t)) X (let ((print-escape-newlines t)) X (concat "'" (prin1-to-string a)))) X ((math-scalarp a) X (let ((calc-group-digits nil) X (calc-point-char ".") X (calc-frac-format (if (> (length calc-frac-format) 1) "::" ":")) X (calc-complex-format nil) X (calc-hms-format "%s@ %s' %s\"") X (calc-language nil)) X (math-format-number a))) X (t X (calc-extensions) X (math-format-flat-expr-fancy a prec))) X) X X X X;;; Format a number as a string. X(defun math-format-number (a) ; [X N] [Public] X (cond X ((eq calc-display-raw t) (format "%s" a)) X ((integerp a) X (if (not (or calc-group-digits calc-leading-zeros)) X (if (= calc-number-radix 10) X (int-to-string a) X (if (< a 0) X (concat "-" (math-format-number (- a))) X (calc-extensions) X (if math-radix-explicit-format X (if calc-radix-formatter X (funcall calc-radix-formatter X calc-number-radix X (if (= calc-number-radix 2) X (math-format-binary a) X (math-format-radix a))) X (format "%d#%s" calc-number-radix X (if (= calc-number-radix 2) X (math-format-binary a) X (math-format-radix a)))) X (math-format-radix a)))) X (math-format-number (math-bignum a)))) X ((stringp a) a) X ((eq (car a) 'bigpos) (math-format-bignum (cdr a))) X ((eq (car a) 'bigneg) (concat "-" (math-format-bignum (cdr a)))) X ((eq (car a) 'frac) X (if (> (length calc-frac-format) 1) X (if (Math-integer-negp (nth 1 a)) X (concat "-" (math-format-number (math-neg a))) X (let ((q (math-idivmod (nth 1 a) (nth 2 a)))) X (concat (math-format-number (car q)) X (substring calc-frac-format 0 1) X (let ((math-radix-explicit-format nil)) X (math-format-number (cdr q))) X (substring calc-frac-format 1 2) X (let ((math-radix-explicit-format nil)) X (math-format-number (nth 2 a)))))) X (concat (math-format-number (nth 1 a)) X calc-frac-format X (let ((math-radix-explicit-format nil)) X (math-format-number (nth 2 a)))))) X ((eq (car a) 'float) X (if (Math-integer-negp (nth 1 a)) X (concat "-" (math-format-number (math-neg a))) X (let ((mant (nth 1 a)) X (exp (nth 2 a)) X (fmt (car calc-float-format)) X (figs (nth 1 calc-float-format)) X (point calc-point-char) X str) X (if (and (eq fmt 'fix) X (or (and (< figs 0) (setq figs (- figs))) X (> (+ exp (math-numdigs mant)) (- figs)))) X (progn X (setq mant (math-scale-rounding mant (+ exp figs)) X str (if (integerp mant) X (int-to-string mant) X (math-format-bignum-decimal (cdr mant)))) X (if (<= (length str) figs) X (setq str (concat (make-string (1+ (- figs (length str))) ?0) X str))) X (if (> figs 0) X (setq str (concat (substring str 0 (- figs)) point X (substring str (- figs)))) X (setq str (concat str point))) X (if calc-group-digits X (setq str (math-group-float str)))) X (if (< figs 0) X (setq figs (+ calc-internal-prec figs))) X (if (> figs 0) X (let ((adj (- figs (math-numdigs mant)))) X (if (< adj 0) X (setq mant (math-scale-rounding mant adj) X exp (- exp adj))))) X (setq str (if (integerp mant) X (int-to-string mant) X (math-format-bignum-decimal (cdr mant)))) X (let* ((len (length str)) X (dpos (+ exp len))) X (if (and (eq fmt 'float) X (<= dpos (+ calc-internal-prec calc-display-sci-high)) X (>= dpos (+ calc-display-sci-low 2))) X (progn X (cond X ((= dpos 0) X (setq str (concat "0" point str))) X ((and (<= exp 0) (> dpos 0)) X (setq str (concat (substring str 0 dpos) point X (substring str dpos)))) X ((> exp 0) X (setq str (concat str (make-string exp ?0) point))) X (t ; (< dpos 0) X (setq str (concat "0" point X (make-string (- dpos) ?0) str)))) X (if calc-group-digits X (setq str (math-group-float str)))) X (let* ((eadj (+ exp len)) X (scale (if (eq fmt 'eng) X (1+ (% (+ eadj 300002) 3)) X 1))) X (if (> scale (length str)) X (setq str (concat str (make-string (- scale (length str)) X ?0)))) X (if (< scale (length str)) X (setq str (concat (substring str 0 scale) point X (substring str scale)))) X (if calc-group-digits X (setq str (math-group-float str))) X (setq str (concat str X (if (eq calc-language 'math) X "*10.^" "e") X (int-to-string (- eadj scale)))))))) X str))) X (t X (calc-extensions) X (math-format-number-fancy a))) X) X X(defvar math-radix-explicit-format t) X X(defun math-format-bignum (a) ; [X L] X (if (and (= calc-number-radix 10) X (not calc-leading-zeros) X (not calc-group-digits)) X (math-format-bignum-decimal a) X (calc-extensions) X (math-format-bignum-fancy a)) X) X X(defun math-format-bignum-decimal (a) ; [X L] X (if a X (let ((s "")) X (while (cdr (cdr a)) X (setq s (concat (format "%06d" (+ (* (nth 1 a) 1000) (car a))) s) X a (cdr (cdr a)))) X (concat (int-to-string (+ (* (or (nth 1 a) 0) 1000) (car a))) s)) X "0") X) X X X X;;; Parse a simple number in string form. [N X] [Public] X(defun math-read-number (s) X (math-normalize X (cond X X ;; Integers (most common case) X ((string-match "\\` *\$[0-9]+\$ *\\'" s) X (let ((digs (math-match-substring s 1))) X (if (and (eq calc-language 'c) X (> (length digs) 1) X (eq (aref digs 0) ?0)) X (math-read-number (concat "8#" digs)) X (if (<= (length digs) 6) X (string-to-int digs) X (cons 'bigpos (math-read-bignum digs)))))) X X ;; Clean up the string if necessary X ((string-match "\\`\$.*\$[ \t\n]+\$[^\001]\$*\\'" s) X (math-read-number (concat (math-match-substring s 1) X (math-match-substring s 2)))) X X ;; Minus sign X ((string-match "^[-_]\$.*\$$" s) X (let ((val (math-read-number (math-match-substring s 1)))) X (and val (math-neg val)))) X X ;; Plus sign X ((string-match "^\\+\$.*\$$" s) X (math-read-number (math-match-substring s 1))) X X ;; Forms that require extensions module X ((string-match "[a-df-zA-DF-Z/@'\"#^]" s) X (calc-extensions) X (math-read-number-fancy s)) X X ;; Integer+fractions X ((string-match "^\$.*\$[:/]\$.*\$[:/]\$.*\$$" s) X (let ((int (math-match-substring s 1)) X (num (math-match-substring s 2)) X (den (math-match-substring s 3))) X (let ((int (if (> (length int) 0) (math-read-number int) 0)) X (num (if (> (length num) 0) (math-read-number num) 1)) X (den (if (> (length num) 0) (math-read-number den) 1))) X (and int num den X (math-integerp int) (math-integerp num) (math-integerp den) X (not (math-zerop den)) X (list 'frac (math-add num (math-mul int den)) den))))) X X ;; Fractions X ((string-match "^\$.*\$[:/]\$.*\$$" s) X (let ((num (math-match-substring s 1)) X (den (math-match-substring s 2))) X (let ((num (if (> (length num) 0) (math-read-number num) 1)) X (den (if (> (length num) 0) (math-read-number den) 1))) X (and num den (math-integerp num) (math-integerp den) X (not (math-zerop den)) X (list 'frac num den))))) X X ;; Decimal point X ((string-match "^\$[0-9]*\$\\.\$[0-9]*\$$" s) X (let ((int (math-match-substring s 1)) X (frac (math-match-substring s 2))) X (let ((ilen (length int)) X (flen (length frac))) X (let ((int (if (> ilen 0) (math-read-number int) 0)) X (frac (if (> flen 0) (math-read-number frac) 0))) X (and int frac (or (> ilen 0) (> flen 0)) X (list 'float X (math-add (math-scale-int int flen) frac) X (- flen))))))) X X ;; "e" notation X ((string-match "^\$.*\$[eE]\$[-+]?[0-9]+\$$" s) X (let ((mant (math-match-substring s 1)) X (exp (math-match-substring s 2))) X (let ((mant (if (> (length mant) 0) (math-read-number mant) 1)) X (exp (string-to-int exp))) X (and mant (math-realp mant) X (let ((mant (math-float mant))) X (list 'float (nth 1 mant) (+ (nth 2 mant) exp))))))) X X ;; Syntax error! X (t nil))) X) X X(defun math-match-substring (s n) X (if (match-beginning n) X (substring s (match-beginning n) (match-end n)) X "") X) X X(defun math-read-bignum (s) ; [l X] X (if (> (length s) 3) X (cons (string-to-int (substring s -3)) X (math-read-bignum (substring s 0 -3))) X (list (string-to-int s))) X) X X(defun math-read-radix-digit (dig) ; [D S; Z S] X (if (> dig ?9) X (if (< dig ?A) X nil X (- dig 55)) X (if (>= dig ?0) X (- dig ?0) X nil)) X) X X X X;;; Algebraic expression parsing. [Public] X X(defun math-read-exprs (exp-str) X (let ((exp-pos 0) X (exp-old-pos 0) X (exp-keep-spaces nil) X exp-token exp-data) X (if calc-language-input-filter X (setq exp-str (funcall calc-language-input-filter exp-str))) X (while (setq exp-token (string-match "\\.\\." exp-str)) X (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots" X (substring exp-str (+ exp-token 2))))) X (math-read-token) X (let ((val (catch 'syntax (math-read-expr-list)))) X (if (stringp val) X (list 'error exp-old-pos val) X (if (equal exp-token 'end) X val X (list 'error exp-old-pos "Syntax error"))))) X) X X(defun math-read-expr-list () X (let* ((exp-keep-spaces nil) X (val (list (math-read-expr-level 0))) X (last val)) X (while (equal exp-data ",") X (math-read-token) X (let ((rest (list (math-read-expr-level 0)))) X (setcdr last rest) X (setq last rest))) X val) X) X X(defun math-read-token () X (if (>= exp-pos (length exp-str)) X (setq exp-old-pos exp-pos X exp-token 'end X exp-data "\000") X (let ((ch (elt exp-str exp-pos))) X (setq exp-old-pos exp-pos) X (cond ((memq ch '(32 10)) X (setq exp-pos (1+ exp-pos)) X (if exp-keep-spaces X (setq exp-token 'space X exp-data " ") X (math-read-token))) X ((or (and (>= ch ?a) (<= ch ?z)) X (and (>= ch ?A) (<= ch ?Z))) X (string-match (if (eq calc-language 'tex) X "[a-zA-Z0-9']*" X "[a-zA-Z0-9'_]*") X exp-str exp-pos) X (setq exp-token 'symbol X exp-pos (match-end 0) X exp-data (math-restore-dashes X (math-match-substring exp-str 0)))) X ((or (and (>= ch ?0) (<= ch ?9)) X (memq ch '(?\. ?_))) X (or (and (eq calc-language 'c) X (string-match "0[xX][0-9a-fA-F]+" exp-str exp-pos)) X (string-match "_?\$[0-9]+.?0*@ *\$?\$[0-9]+.?0*' *\$?\$[0-9]+\\(#\\|\\^\\^\$[0-9a-zA-Z:]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\$[eE][-+_]?[0-9]+\$?\"?\\)?" exp-str exp-pos)) X (setq exp-token 'number X exp-data (math-match-substring exp-str 0) X exp-pos (match-end 0))) X ((eq ch ?\$) X (string-match "\\$+" exp-str exp-pos) X (setq exp-token 'dollar X exp-data (- (match-end 0) (match-beginning 0)) X exp-pos (match-end 0))) X ((eq (string-match "~=\\|<=\\|>=\\|<>\\|/=\\|\\+/-\\|\\\\dots\\|\\*\\*\\|<<\\|>>\\|==\\|!=\\|&&\\|||\\|!!" X exp-str exp-pos) X exp-pos) X (setq exp-token 'punc X exp-data (math-match-substring exp-str 0) X exp-pos (match-end 0))) X ((and (eq ch ?\") X (string-match "\$\"\\([^\"\\]\\|\\\\.\$*\\)\$\"\\|\\'\$" exp-str exp-pos)) X (setq exp-token 'string X exp-data (math-match-substring exp-str 1) X exp-pos (match-end 0))) X ((and (= ch ?\\) (eq calc-language 'tex)) X (or (string-match "\\\\hbox *{\$[a-zA-Z0-9]+\$}" exp-str exp-pos) X (string-match "\$\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\$\\)" exp-str exp-pos)) X (setq exp-token 'symbol X exp-pos (match-end 0) X exp-data (math-restore-dashes X (math-match-substring exp-str 1))) X (if (or (equal exp-data "\\left") X (equal exp-data "\\right")) X (math-read-token))) X (t X (if (and (eq ch ?\{) (eq calc-language 'tex)) X (setq ch ?$)) X (if (and (eq ch ?\}) (eq calc-language 'tex)) X (setq ch ?$)) X (setq exp-token 'punc X exp-data (char-to-string ch) X exp-pos (1+ exp-pos)))))) X) X X(defconst math-standard-opers X '( ( "u+" ident -1 1000 ) X ( "u-" neg -1 1000 ) X ( "u!" calcFunc-lnot -1 1000 ) X ( "mod" mod 400 400 ) X ( "+/-" sdev 300 300 ) X ( "!" calcFunc-fact 210 -1 ) X ( "^" ^ 201 200 ) X ( "*" * 196 195 ) X ( "2x" * 196 195 ) X ( "/" / 190 191 ) X ( "%" % 190 191 ) X ( "\\" calcFunc-idiv 190 191 ) X ( "+" + 180 181 ) X ( "-" - 180 181 ) X ( "|" | 170 171 ) X ( "<" calcFunc-lt 160 161 ) X ( ">" calcFunc-gt 160 161 ) X ( "<=" calcFunc-leq 160 161 ) X ( ">=" calcFunc-geq 160 161 ) X ( "=" calcFunc-eq 160 161 ) X ( "==" calcFunc-eq 160 161 ) X ( "!=" calcFunc-neq 160 161 ) X ( "&&" calcFunc-land 110 111 ) X ( "||" calcFunc-lor 100 101 ) X ( "?" calcFunc-if 91 90 ) X)) X(setq math-expr-opers math-standard-opers) X(setq math-expr-function-mapping nil) X(setq math-expr-variable-mapping nil) X X(defun math-read-expr-level (exp-prec) X (let* ((x (math-read-factor)) op) X (while (and (or (and (setq op (assoc exp-data math-expr-opers)) X (/= (nth 2 op) -1)) X (and (or (eq (nth 2 op) -1) X (memq exp-token '(symbol number dollar)) X (equal exp-data "(") X (and (equal exp-data "[") X (not (eq calc-language 'math)) X (not (and exp-keep-spaces X (eq (car-safe x) 'vec))))) X (setq op (assoc "2x" math-expr-opers)))) X (>= (nth 2 op) exp-prec)) X (if (not (equal (car op) "2x")) X (math-read-token)) X (and (memq (nth 1 op) '(sdev mod)) X (calc-extensions)) X (setq x (cond ((eq (nth 3 op) -1) X (if (eq (nth 1 op) 'ident) X x X (list (nth 1 op) x))) X ((equal (car op) "?") X (let ((y (math-read-expr-level 0))) X (or (equal exp-data ":") X (throw 'syntax "Expected ':'")) X (math-read-token) X (list (nth 1 op) X x X y X (math-read-expr-level (nth 3 op))))) X (t (list (nth 1 op) X x X (math-read-expr-level (nth 3 op))))))) X x) X) X X(defun math-remove-dashes (x) X (if (string-match "\\`\$.*\$-\$.*\$\\'" x) X (math-remove-dashes X (concat (math-match-substring x 1) "_" (math-match-substring x 2))) X x) X) X X(defun math-restore-dashes (x) X (if (string-match "\\`\$.*\$_\$.*\$\\'" x) X (math-restore-dashes X (concat (math-match-substring x 1) "-" (math-match-substring x 2))) X x) X) X X(defun math-read-factor () X (let (op) X (cond ((eq exp-token 'number) X (let ((num (math-read-number exp-data))) X (if (not num) X (progn X (setq exp-old-pos exp-pos) X (throw 'syntax "Bad format"))) X (math-read-token) X (if (and math-read-expr-quotes X (consp num)) X (list 'quote num) X num))) X ((or (equal exp-data "-") X (equal exp-data "+") X (equal exp-data "!") X (equal exp-data "|")) X (setq exp-data (concat "u" exp-data)) X (math-read-factor)) X ((and (setq op (assoc exp-data math-expr-opers)) X (eq (nth 2 op) -1)) X (math-read-token) X (let ((val (math-read-expr-level (nth 3 op)))) X (cond ((eq (nth 1 op) 'ident) X val) X ((and (math-numberp val) X (equal (car op) "u-")) X (math-neg val)) X (t (list (nth 1 op) val))))) X ((eq exp-token 'symbol) X (let ((sym (intern exp-data))) X (math-read-token) X (if (equal exp-data calc-function-open) X (progn X (math-read-token) X (let ((args (if (equal exp-data calc-function-close) X nil X (math-read-expr-list)))) X (if (not (or (equal exp-data calc-function-close) X (eq exp-token 'end))) X (throw 'syntax "Expected `)'")) X (math-read-token) X (let ((f (assq sym math-expr-function-mapping))) X (if f X (setq sym (cdr f)) X (or (string-match "-" (symbol-name sym)) X (setq sym (intern (concat "calcFunc-" X (symbol-name sym))))))) X (cons sym args))) X (if math-read-expr-quotes X sym X (let ((val (list 'var X (intern (math-remove-dashes X (symbol-name sym))) X (if (string-match "-" (symbol-name sym)) X sym X (intern (concat "var-" X (symbol-name sym))))))) X (let ((v (assq (nth 1 val) math-expr-variable-mapping))) X (and v (setq val (list 'var X (intern X (substring (symbol-name (cdr v)) 4)) X (cdr v))))) X (while (and (memq calc-language '(c pascal)) X (equal exp-data "[")) X (math-read-token) X (setq val (append (list 'calcFunc-subscr val) X (math-read-expr-list))) X (if (equal exp-data "]") X (math-read-token) X (throw 'syntax "Expected ']'"))) X val))))) X ((eq exp-token 'dollar) X (if (>= (length calc-dollar-values) exp-data) X (let ((num exp-data)) X (math-read-token) X (setq calc-dollar-used (max calc-dollar-used num)) X (math-check-complete (nth (1- num) calc-dollar-values))) X (throw 'syntax (if calc-dollar-values X "Too many $'s" X "$'s not allowed in this context")))) X ((equal exp-data "(") X (let* ((exp (let ((exp-keep-spaces nil)) X (math-read-token) X (math-read-expr-level 0)))) X (let ((exp-keep-spaces nil)) X (cond X ((equal exp-data ",") X (progn X (math-read-token) X (let ((exp2 (math-read-expr-level 0))) X (setq exp X (if (and exp2 (math-realp exp) (math-realp exp2)) X (math-normalize (list 'cplx exp exp2)) X (list '+ exp (list '* exp2 '(var i var-i)))))))) X ((equal exp-data ";") X (progn X (math-read-token) X (let ((exp2 (math-read-expr-level 0))) X (setq exp (if (and exp2 (math-realp exp) X (math-anglep exp2)) X (math-normalize (list 'polar exp exp2)) X (list '* exp X (list 'calcFunc-exp X (list '* exp2 X '(var i var-i))))))))) X ((equal exp-data "\\dots") X (progn X (math-read-token) X (let ((exp2 (math-read-expr-level 0))) X (setq exp X (list 'intv X (if (equal exp-data ")") 0 1) X exp X exp2))))))) X (if (not (or (equal exp-data ")") X (and (equal exp-data "]") (eq (car-safe exp) 'intv)) X (eq exp-token 'end))) X (throw 'syntax "Expected `)'")) X (math-read-token) X exp)) X ((eq exp-token 'string) X (calc-extensions) X (math-read-string)) X ((equal exp-data "[") X (calc-extensions) X (math-read-brackets t "]")) X ((equal exp-data "{") X (calc-extensions) X (math-read-brackets nil "}")) X (t (throw 'syntax "Expected a number")))) X) X X(defvar math-read-expr-quotes nil) X X X X X;;; Bug reporting X X(defun report-calc-bug (topic) X "Report a bug in Calc, the GNU Emacs calculator. XPrompts for bug subject. Leaves you in a mail buffer." X (interactive "sBug Subject: ") X (mail nil calc-bug-address topic) X (goto-char (point-max)) X (insert "\nIn Calc 1.01, Emacs " (emacs-version) "\n\n") X (message (substitute-command-keys "Type \\[mail-send] to send bug report.")) X) X X X X;;; User-programmability. X X(defmacro defmath (func args &rest body) ; [Public] X (calc-extensions) X (math-do-defmath func args body) X) X X X X(if calc-always-load-extensions X (calc-extensions) X) X X X X;;; End. X SHAR_EOF echo "File calc.el is complete" chmod 0664 calc.el || echo "restore of calc.el fails" set `wc -c calc.el`;Sum=$1 if test "$Sum" != "124988" then echo original size 124988, current size $Sum;fi echo "x - extracting calc-ext.el (Text)" sed 's/^X//' << 'SHAR_EOF' > calc-ext.el && X;; Calculator for GNU Emacs, part II X;; Copyright (C) 1990 Dave Gillespie X X;; This file is part of GNU Emacs. X X;; GNU Emacs is distributed in the hope that it will be useful, X;; but WITHOUT ANY WARRANTY. No author or distributor X;; accepts responsibility to anyone for the consequences of using it X;; or for whether it serves any particular purpose or works at all, X;; unless he says so in writing. Refer to the GNU Emacs General Public X;; License for full details. X X;; Everyone is granted permission to copy, modify and redistribute X;; GNU Emacs, but only under the conditions described in the X;; GNU Emacs General Public License. A copy of this license is X;; supposed to have been given to you along with GNU Emacs so you X;; can know your rights and responsibilities. It should be in a X;; file named COPYING. Among other things, the copyright notice X;; and this notice must be preserved on all copies. X X X X(provide 'calc-ext) X X(setq calc-extensions-loaded t) X X;;; This function is the autoload "hook" to cause this file to be loaded. X(defun calc-extensions () X t X) X X;;; Auto-load part I, in case this part was loaded first. X(if (fboundp 'calc) X (and (eq (car-safe (symbol-function 'calc)) 'autoload) X (load (nth 1 (symbol-function 'calc)))) X (error "Main part of Calc must be present in order to load this file.")) X X;;; If the following fails with "Cannot open load file: calc" X;;; do "M-x load-file calc.elc" before compiling calc-ext.el. X(require 'calc) ;;; This should only occur in the byte compiler. X X X X(progn X (define-key calc-mode-map ":" 'calc-fdiv) X (define-key calc-mode-map "\\" 'calc-idiv) X (define-key calc-mode-map "|" 'calc-concat) X (define-key calc-mode-map "!" 'calc-factorial) X (define-key calc-mode-map "A" 'calc-abs) X (define-key calc-mode-map "B" 'calc-log) X (define-key calc-mode-map "C" 'calc-cos) X (define-key calc-mode-map "D" 'calc-redo) X (define-key calc-mode-map "E" 'calc-exp) X (define-key calc-mode-map "F" 'calc-floor) X (define-key calc-mode-map "G" 'calc-argument) X (define-key calc-mode-map "H" 'calc-hyperbolic) X (define-key calc-mode-map "I" 'calc-inverse) X (define-key calc-mode-map "J" 'calc-conj) X (define-key calc-mode-map "K" 'calc-call-last-kbd-macro) X (define-key calc-mode-map "L" 'calc-ln) X (define-key calc-mode-map "M" 'calc-more-recursion-depth) X (define-key calc-mode-map "N" 'calc-eval-num) X (define-key calc-mode-map "P" 'calc-pi) X (define-key calc-mode-map "Q" 'calc-sqrt) X (define-key calc-mode-map "R" 'calc-round) X (define-key calc-mode-map "S" 'calc-sin) X (define-key calc-mode-map "T" 'calc-tan) X (define-key calc-mode-map "U" 'calc-undo) X (define-key calc-mode-map "X" 'calc-last-x) X (define-key calc-mode-map "l" 'calc-let) X (define-key calc-mode-map "r" 'calc-recall) X (define-key calc-mode-map "s" 'calc-store) X (define-key calc-mode-map "x" 'calc-execute-extended-command) X X (define-key calc-mode-map "(" 'calc-begin-complex) X (define-key calc-mode-map ")" 'calc-end-complex) X (define-key calc-mode-map "[" 'calc-begin-vector) X (define-key calc-mode-map "]" 'calc-end-vector) X (define-key calc-mode-map "," 'calc-comma) X (define-key calc-mode-map ";" 'calc-semi) X (define-key calc-mode-map "`" 'calc-edit) X (define-key calc-mode-map "=" 'calc-evaluate) X (define-key calc-mode-map "~" 'calc-num-prefix) X (define-key calc-mode-map "y" 'calc-copy-to-buffer) X (define-key calc-mode-map "\C-k" 'calc-kill) X (define-key calc-mode-map "\M-k" 'calc-copy-as-kill) X (define-key calc-mode-map "\C-w" 'calc-kill-region) X (define-key calc-mode-map "\M-w" 'calc-copy-region-as-kill) X (define-key calc-mode-map "\C-y" 'calc-yank) X (define-key calc-mode-map "\C-_" 'calc-undo) X X (define-key calc-mode-map "a" nil) X (define-key calc-mode-map "a?" 'calc-a-prefix-help) X (define-key calc-mode-map "ab" 'calc-substitute) X (define-key calc-mode-map "ac" 'calc-collect) X (define-key calc-mode-map "ad" 'calc-derivative) X (define-key calc-mode-map "ae" 'calc-simplify-extended) X (define-key calc-mode-map "ai" 'calc-integral) X (define-key calc-mode-map "ar" 'calc-rewrite) X (define-key calc-mode-map "as" 'calc-simplify) X (define-key calc-mode-map "at" 'calc-taylor) X (define-key calc-mode-map "ax" 'calc-expand) X (define-key calc-mode-map "aI" 'calc-integral-limit) X (define-key calc-mode-map "aS" 'calc-solve-for) X (define-key calc-mode-map "a=" 'calc-equal-to) X (define-key calc-mode-map "a#" 'calc-not-equal-to) X (define-key calc-mode-map "a<" 'calc-less-than) X (define-key calc-mode-map "a>" 'calc-greater-than) X (define-key calc-mode-map "a[" 'calc-less-equal) X (define-key calc-mode-map "a]" 'calc-greater-equal) X (define-key calc-mode-map "a{" 'calc-in-set) X (define-key calc-mode-map "a&" 'calc-logical-and) X (define-key calc-mode-map "a|" 'calc-logical-or) X (define-key calc-mode-map "a!" 'calc-logical-not) X X (define-key calc-mode-map "b" nil) X (define-key calc-mode-map "b?" 'calc-b-prefix-help) X (define-key calc-mode-map "ba" 'calc-and) X (define-key calc-mode-map "bc" 'calc-clip) X (define-key calc-mode-map "bd" 'calc-diff) X (define-key calc-mode-map "bl" 'calc-lshift-binary) X (define-key calc-mode-map "bn" 'calc-not) X (define-key calc-mode-map "bo" 'calc-or) X (define-key calc-mode-map "br" 'calc-rshift-binary) X (define-key calc-mode-map "bR" 'calc-rotate-binary) X (define-key calc-mode-map "bs" 'calc-shift-binary) X (define-key calc-mode-map "bw" 'calc-word-size) X (define-key calc-mode-map "bx" 'calc-xor) X X (define-key calc-mode-map "c" nil) X (define-key calc-mode-map "c?" 'calc-c-prefix-help) X (define-key calc-mode-map "c1" 'calc-clean-1) X (define-key calc-mode-map "c2" 'calc-clean-2) X (define-key calc-mode-map "c3" 'calc-clean-3) X (define-key calc-mode-map "cc" 'calc-clean) X (define-key calc-mode-map "cd" 'calc-to-degrees) X (define-key calc-mode-map "cf" 'calc-float) X (define-key calc-mode-map "ch" 'calc-to-hms) X (define-key calc-mode-map "cp" 'calc-polar) X (define-key calc-mode-map "cr" 'calc-to-radians) X (define-key calc-mode-map "cF" 'calc-fraction) X X (define-key calc-mode-map "d" nil) X (define-key calc-mode-map "d?" 'calc-d-prefix-help) X (define-key calc-mode-map "d0" 'calc-decimal-radix) X (define-key calc-mode-map "d2" 'calc-binary-radix) X (define-key calc-mode-map "d6" 'calc-hex-radix) X (define-key calc-mode-map "d8" 'calc-octal-radix) X (define-key calc-mode-map "db" 'calc-line-breaking) X (define-key calc-mode-map "dc" 'calc-complex-notation) X (define-key calc-mode-map "de" 'calc-eng-notation) X (define-key calc-mode-map "df" 'calc-fix-notation) X (define-key calc-mode-map "dg" 'calc-group-digits) X (define-key calc-mode-map "dh" 'calc-hms-notation) X (define-key calc-mode-map "di" 'calc-i-notation) X (define-key calc-mode-map "dj" 'calc-j-notation) X (define-key calc-mode-map "dl" 'calc-line-numbering) X (define-key calc-mode-map "dn" 'calc-normal-notation) X (define-key calc-mode-map "do" 'calc-over-notation) X (define-key calc-mode-map "dr" 'calc-radix) X (define-key calc-mode-map "ds" 'calc-sci-notation) X (define-key calc-mode-map "dt" 'calc-truncate-stack) X (define-key calc-mode-map "dw" 'calc-auto-why) X (define-key calc-mode-map "dz" 'calc-leading-zeros) X (define-key calc-mode-map "dB" 'calc-big-language) X (define-key calc-mode-map "dC" 'calc-c-language) X (define-key calc-mode-map "dF" 'calc-fortran-language) X (define-key calc-mode-map "dM" 'calc-mathematica-language) X (define-key calc-mode-map "dN" 'calc-normal-language) X (define-key calc-mode-map "dO" 'calc-flat-language) X (define-key calc-mode-map "dP" 'calc-pascal-language) X (define-key calc-mode-map "dT" 'calc-tex-language) X (define-key calc-mode-map "dU" 'calc-unformatted-language) X (define-key calc-mode-map "d[" 'calc-truncate-up) X (define-key calc-mode-map "d]" 'calc-truncate-down) X (define-key calc-mode-map "d." 'calc-point-char) X (define-key calc-mode-map "d," 'calc-group-char) X (define-key calc-mode-map "d\"" 'calc-display-strings) X (define-key calc-mode-map "d<" 'calc-left-justify) X (define-key calc-mode-map "d=" 'calc-center-justify) X (define-key calc-mode-map "d>" 'calc-right-justify) X (define-key calc-mode-map "d'" 'calc-display-raw) X (define-key calc-mode-map "d`" 'calc-realign) X (define-key calc-mode-map "d~" 'calc-refresh) X X (define-key calc-mode-map "k" nil) X (define-key calc-mode-map "k?" 'calc-k-prefix-help) X (define-key calc-mode-map "ka" 'calc-random-again) X (define-key calc-mode-map "kb" 'calc-choose) X (define-key calc-mode-map "kd" 'calc-double-factorial) X (define-key calc-mode-map "kf" 'calc-prime-factors) X (define-key calc-mode-map "kg" 'calc-gcd) X (define-key calc-mode-map "kl" 'calc-lcm) X (define-key calc-mode-map "km" 'calc-moebius) X (define-key calc-mode-map "kn" 'calc-next-prime) X (define-key calc-mode-map "kp" 'calc-prime-test) X (define-key calc-mode-map "kr" 'calc-random) X (define-key calc-mode-map "kt" 'calc-totient) X (define-key calc-mode-map "kG" 'calc-extended-gcd) X X (define-key calc-mode-map "m" nil) X (define-key calc-mode-map "m?" 'calc-m-prefix-help) X (define-key calc-mode-map "ma" 'calc-algebraic-mode) X (define-key calc-mode-map "md" 'calc-degrees-mode) X (define-key calc-mode-map "mf" 'calc-frac-mode) X (define-key calc-mode-map "mh" 'calc-hms-mode) X (define-key calc-mode-map "mm" 'calc-save-modes) X (define-key calc-mode-map "mp" 'calc-polar-mode) X (define-key calc-mode-map "mr" 'calc-radians-mode) X (define-key calc-mode-map "ms" 'calc-symbolic-mode) X (define-key calc-mode-map "mw" 'calc-working) X (define-key calc-mode-map "mx" 'calc-always-load-extensions) X (define-key calc-mode-map "mA" 'calc-alg-simplify-mode) X (define-key calc-mode-map "mB" 'calc-bin-simplify-mode) X (define-key calc-mode-map "mD" 'calc-default-simplify-mode) X (define-key calc-mode-map "mE" 'calc-ext-simplify-mode) X (define-key calc-mode-map "mN" 'calc-num-simplify-mode) X (define-key calc-mode-map "mO" 'calc-no-simplify-mode) X (define-key calc-mode-map "mU" 'calc-units-simplify-mode) X X (define-key calc-mode-map "t" nil) X (define-key calc-mode-map "t?" 'calc-t-prefix-help) X (define-key calc-mode-map "tb" 'calc-trail-backward) X (define-key calc-mode-map "td" 'calc-trail-display) X (define-key calc-mode-map "tf" 'calc-trail-forward) X (define-key calc-mode-map "th" 'calc-trail-here) X (define-key calc-mode-map "ti" 'calc-trail-in) X (define-key calc-mode-map "tk" 'calc-trail-kill) X (define-key calc-mode-map "tm" 'calc-trail-marker) X (define-key calc-mode-map "tn" 'calc-trail-next) X (define-key calc-mode-map "to" 'calc-trail-out) X (define-key calc-mode-map "tp" 'calc-trail-previous) X (define-key calc-mode-map "tr" 'calc-trail-isearch-backward) X (define-key calc-mode-map "ts" 'calc-trail-isearch-forward) X (define-key calc-mode-map "ty" 'calc-trail-yank) X (define-key calc-mode-map "t[" 'calc-trail-first) X (define-key calc-mode-map "t]" 'calc-trail-last) X (define-key calc-mode-map "t<" 'calc-trail-scroll-left) X (define-key calc-mode-map "t>" 'calc-trail-scroll-right) X X (define-key calc-mode-map "u" 'nil) X (define-key calc-mode-map "u?" 'calc-u-prefix-help) X (define-key calc-mode-map "ub" 'calc-base-units) X (define-key calc-mode-map "uc" 'calc-convert-units) X (define-key calc-mode-map "ud" 'calc-define-unit) X (define-key calc-mode-map "ue" 'calc-explain-units) X (define-key calc-mode-map "ug" 'calc-get-unit-definition) X (define-key calc-mode-map "up" 'calc-permanent-units) X (define-key calc-mode-map "ur" 'calc-remove-units) X (define-key calc-mode-map "us" 'calc-simplify-units) X (define-key calc-mode-map "ut" 'calc-convert-temperature) X (define-key calc-mode-map "uu" 'calc-undefine-unit) X (define-key calc-mode-map "uv" 'calc-enter-units-table) X (define-key calc-mode-map "ux" 'calc-extract-units) X (define-key calc-mode-map "uV" 'calc-view-units-table) X X (define-key calc-mode-map "v" 'nil) X (define-key calc-mode-map "v?" 'calc-v-prefix-help) X (define-key calc-mode-map "va" 'calc-arrange-vector) X (define-key calc-mode-map "vb" 'calc-build-vector) X (define-key calc-mode-map "vc" 'calc-mcol) X (define-key calc-mode-map "vd" 'calc-diag) X (define-key calc-mode-map "vh" 'calc-histogram) X (define-key calc-mode-map "vi" 'calc-ident) X (define-key calc-mode-map "vl" 'calc-vlength) X (define-key calc-mode-map "vn" 'calc-rnorm) X (define-key calc-mode-map "vp" 'calc-pack) X (define-key calc-mode-map "vr" 'calc-mrow) X (define-key calc-mode-map "vs" 'calc-sort) X (define-key calc-mode-map "vt" 'calc-transpose) X (define-key calc-mode-map "vu" 'calc-unpack) X (define-key calc-mode-map "vx" 'calc-index) X (define-key calc-mode-map "vA" 'calc-apply) X (define-key calc-mode-map "vC" 'calc-cross) X (define-key calc-mode-map "vD" 'calc-mdet) X (define-key calc-mode-map "vI" 'calc-inv) X (define-key calc-mode-map "vJ" 'calc-conj-transpose) X (define-key calc-mode-map "vL" 'calc-mlud) X (define-key calc-mode-map "vM" 'calc-map) X (define-key calc-mode-map "vN" 'calc-cnorm) X (define-key calc-mode-map "vR" 'calc-reduce) X (define-key calc-mode-map "vT" 'calc-mtrace) X (define-key calc-mode-map "v<" 'calc-matrix-left-justify) X (define-key calc-mode-map "v=" 'calc-matrix-center-justify) X (define-key calc-mode-map "v>" 'calc-matrix-right-justify) X (define-key calc-mode-map "v," 'calc-vector-commas) X (define-key calc-mode-map "v[" 'calc-vector-brackets) X (define-key calc-mode-map "v{" 'calc-vector-braces) X (define-key calc-mode-map "v(" 'calc-vector-parens) X (aset calc-mode-map ?V (aref calc-mode-map ?v)) X X (define-key calc-mode-map "z" 'nil) X (define-key calc-mode-map "z?" 'calc-z-prefix-help) X X (define-key calc-mode-map "Z" 'nil) X (define-key calc-mode-map "Z?" 'calc-shift-Z-prefix-help) X (define-key calc-mode-map "Zd" 'calc-user-define) X (define-key calc-mode-map "Ze" 'calc-user-define-edit) X (define-key calc-mode-map "Zf" 'calc-user-define-formula) X (define-key calc-mode-map "Zg" 'calc-get-user-defn) X (define-key calc-mode-map "Zk" 'calc-user-define-kbd-macro) X (define-key calc-mode-map "Zp" 'calc-user-define-permanent) X (define-key calc-mode-map "Zu" 'calc-user-undefine) X (define-key calc-mode-map "Zv" 'calc-permanent-variable) X (define-key calc-mode-map "Z[" 'calc-kbd-if) X (define-key calc-mode-map "Z:" 'calc-kbd-else) X (define-key calc-mode-map "Z|" 'calc-kbd-else-if) X (define-key calc-mode-map "Z]" 'calc-kbd-end-if) X (define-key calc-mode-map "Z<" 'calc-kbd-repeat) X (define-key calc-mode-map "Z>" 'calc-kbd-end-repeat) X (define-key calc-mode-map "Z(" 'calc-kbd-for) X (define-key calc-mode-map "Z)" 'calc-kbd-end-for) X (define-key calc-mode-map "Z{" 'calc-kbd-loop) X (define-key calc-mode-map "Z}" 'calc-kbd-end-loop) X (define-key calc-mode-map "Z/" 'calc-kbd-break) X (define-key calc-mode-map "Z`" 'calc-kbd-push) X (define-key calc-mode-map "Z'" 'calc-kbd-pop) X (define-key calc-mode-map "Z=" 'calc-kbd-report) X (define-key calc-mode-map "Z#" 'calc-kbd-query) X X) X X X X X;;;; Miscellaneous. X X(defun calc-record-message (tag &rest args) X (let ((msg (apply 'format args))) X (message "%s" msg) X (calc-record msg tag)) X (calc-clear-command-flag 'clear-message) X) X X X(defun calc-do-prefix-help (msgs group key) X (if (cdr msgs) X (progn X (setq calc-prefix-help-phase X (if (eq this-command last-command) X (% (1+ calc-prefix-help-phase) (1+ (length msgs))) X 0)) X (let ((msg (nth calc-prefix-help-phase msgs))) X (message "%s" (if msg X (concat group ": " msg ":" X (make-string X (- (apply 'max (mapcar 'length msgs)) X (length msg)) 32) X " [MORE]" X (if key X (concat " " (char-to-string key) "-") X "")) X (format "%c-" key))))) X (setq calc-prefix-help-phase 0) X (if key X (if msgs X (message (concat group ": " (car msgs) ": " X (char-to-string key) "-")) X (message (concat group ": (none) " (char-to-string key) "-"))) X (message (concat group ": " (car msgs))))) X (and key X (setq unread-command-char key)) X) X(defvar calc-prefix-help-phase 0) X X X X X;;;; Commands. X X X;;; General. X X(defun calc-inverse (&optional n) X "Next Calculator operation is inverse." X (interactive "P") X (calc-wrapper X (calc-set-command-flag 'keep-flags) X (setq calc-inverse-flag (not calc-inverse-flag) X prefix-arg n) X (message (if calc-inverse-flag "Inverse..." ""))) X) X X(defun calc-invert-func () X (setq calc-inverse-flag (not (calc-is-inverse)) X calc-hyperbolic-flag (calc-is-hyperbolic) X current-prefix-arg nil) X) X X(defun calc-is-inverse () X calc-inverse-flag X) X X(defun calc-hyperbolic (&optional n) X "Next Calculator operation is hyperbolic." X (interactive "P") X (calc-wrapper X (calc-set-command-flag 'keep-flags) X (setq calc-hyperbolic-flag (not calc-hyperbolic-flag) X prefix-arg n) X (message (if calc-hyperbolic-flag "Hyperbolic..." ""))) X) X X(defun calc-hyperbolic-func () X (setq calc-inverse-flag (calc-is-inverse) X calc-hyperbolic-flag (not (calc-is-hyperbolic)) X current-prefix-arg nil) X) X X(defun calc-is-hyperbolic () X calc-hyperbolic-flag X) X X X(defun calc-evaluate (n) X "Evaluate all variables in the expression on the top of the stack. XWith a numeric prefix argument, evaluate each of the top N stack elements." X (interactive "p") X (calc-slow-wrapper X (if (= n 0) X (setq n (calc-stack-size))) X (if (< n 0) X (error "Argument must be positive")) X (calc-with-default-simplification X (calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr X (calc-top-list-n n)))) X (calc-handle-whys)) X) X X X(defun calc-eval-num (n) X "Evaluate numerically the expression on the top of the stack. XThis is only necessary when the calculator is in Symbolic mode." X (interactive "P") X (calc-slow-wrapper X (let* ((nn (prefix-numeric-value n)) X (calc-internal-prec (cond ((>= nn 3) nn) X ((< nn 0) (max (+ calc-internal-prec nn) X 3)) X (t calc-internal-prec))) X (calc-symbolic-mode nil)) X (calc-with-default-simplification X (calc-pop-push-record 1 "num" (math-evaluate-expr (calc-top-n 1))))) X (calc-handle-whys)) X) X X X(defun calc-execute-extended-command (n) X "Just like M-x, but inserts \"calc-\" prefix automatically." X (interactive "P") X (let* ((prompt (concat (calc-num-prefix-name n) "M-x ")) X (cmd (intern (completing-read prompt obarray 'commandp t "calc-")))) X (setq prefix-arg n) X (command-execute cmd)) X) X X X(defun calc-num-prefix (n) X "Use the number at the top of stack as the numeric prefix for the next command. XWith a prefix, push that prefix as a number onto the stack." X (interactive "P") X (calc-wrapper X (if n X (calc-enter-result 0 "" (prefix-numeric-value n)) X (let ((num (calc-top 1))) X (if (math-messy-integerp num) X (setq num (math-trunc num))) X (or (integerp num) X (error "Argument must be a small integer")) X (calc-pop 1) X (setq prefix-arg num) X (message "%d-" num)))) ; a (lame) simulation of the real thing... X) X X X(defun calc-more-recursion-depth (n) X "Double the max-lisp-eval-depth value, in case this limit is wrongly exceeded. XThis also doubles max-specpdl-size." X (interactive "P") X (let ((n (if n (prefix-numeric-value n) 2))) X (if (> n 1) X (setq max-specpdl-size (* max-specpdl-size n) X max-lisp-eval-depth (* max-lisp-eval-depth n)))) X (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth) X) X X(defun calc-less-recursion-depth (n) X "Halve the max-lisp-eval-depth value, in case this limit is too high. XThis also halves max-specpdl-size. XLower limits are 200 and 600, respectively." X (interactive "P") X (let ((n (if n (prefix-numeric-value n) 2))) X (if (> n 1) X (setq max-specpdl-size X (max (/ max-specpdl-size n) 600) X max-lisp-eval-depth X (max (/ max-lisp-eval-depth n) 200)))) X (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth) X) X X X(defun calc-time () X "Push the current time of day on the stack as an HMS form. X\(Why? Why not!)" X (interactive) X (calc-wrapper X (let ((time (current-time-string))) X (calc-enter-result 0 "time" X (list 'mod X (list 'hms X (string-to-int (substring time 11 13)) X (string-to-int (substring time 14 16)) X (string-to-int (substring time 17 19))) X (list 'hms 24 0 0))))) X) X X X X;;; Incomplete forms. X X(defun calc-begin-complex () X "Begin entering a complex number in the Calculator." X (interactive) X (calc-wrapper X (if calc-algebraic-mode X (calc-alg-entry "(") X (calc-push (list 'incomplete calc-complex-mode)))) X) X X(defun calc-end-complex () X "Complete a complex number being entered in the Calculator." X (interactive) X (calc-comma t) X (calc-wrapper X (let ((top (calc-top 1))) X (if (and (eq (car-safe top) 'incomplete) X (eq (nth 1 top) 'intv)) X (progn X (while (< (length top) 5) X (setq top (append top '(0)))) X (calc-enter-result 1 "..)" (cdr top))) X (if (not (and (eq (car-safe top) 'incomplete) X (memq (nth 1 top) '(cplx polar)))) X (error "Not entering a complex number")) X (while (< (length top) 4) X (setq top (append top '(0)))) X (if (not (and (math-realp (nth 2 top)) X (math-anglep (nth 3 top)))) X (error "Components must be real")) X (calc-enter-result 1 "()" (cdr top))))) X) X X(defun calc-begin-vector () X "Begin entering a vector in the Calculator." X (interactive) X (calc-wrapper X (if calc-algebraic-mode X (calc-alg-entry "[") X (calc-push '(incomplete vec)))) X) X X(defun calc-end-vector () X "Complete a vector being entered in the Calculator." X (interactive) X (calc-comma t) X (calc-wrapper X (let ((top (calc-top 1))) X (if (and (eq (car-safe top) 'incomplete) X (eq (nth 1 top) 'intv)) X (progn X (while (< (length top) 5) X (setq top (append top '(0)))) X (setcar (cdr (cdr top)) (1+ (nth 2 top))) X (calc-enter-result 1 "..]" (cdr top))) X (if (not (and (eq (car-safe top) 'incomplete) X (eq (nth 1 top) 'vec))) X (error "Not entering a vector")) X (calc-pop-push-record 1 "[]" (cdr top))))) X) X X(defun calc-comma (&optional allow-polar) X "Separate components of a complex number or vector during entry." X (interactive) X (calc-wrapper X (let ((num (calc-find-first-incomplete X (nthcdr calc-stack-top calc-stack) 1))) X (if (= num 0) X (error "Not entering a vector or complex number")) X (let* ((inc (calc-top num)) X (stuff (calc-top-list (1- num))) X (new (append inc stuff))) X (if (and (null stuff) X (not allow-polar) X (or (eq (nth 1 inc) 'vec) X (< (length new) 4))) X (setq new (append new X (if (= (length new) 2) X '(0) X (nthcdr (1- (length new)) new))))) X (or allow-polar X (if (eq (nth 1 inc) 'polar) X (setq inc (append '(incomplete cplx) (cdr (cdr inc)))) X (if (eq (nth 1 inc) 'intv) X (setq inc (append '(incomplete cplx) X (cdr (cdr (cdr inc)))))))) X (if (and (memq (nth 1 new) '(cplx polar)) X (> (length new) 4)) X (error "Too many components in complex number")) X (calc-pop-push num new)))) X) X X(defun calc-semi () X "Separate parts of a polar complex number or rows of a matrix during entry." X (interactive) X (calc-wrapper X (let ((num (calc-find-first-incomplete X (nthcdr calc-stack-top calc-stack) 1))) X (if (= num 0) X (error "Not entering a vector or complex number")) X (let ((inc (calc-top num)) X (stuff (calc-top-list (1- num)))) X (if (eq (nth 1 inc) 'cplx) X (setq inc (append '(incomplete polar) (cdr (cdr inc)))) X (if (eq (nth 1 inc) 'intv) X (setq inc (append '(incomplete polar) (cdr (cdr (cdr inc))))))) X (cond ((eq (nth 1 inc) 'polar) X (let ((new (append inc stuff))) X (if (> (length new) 4) X (error "Too many components in complex number") X (if (= (length new) 2) X (setq new (append new '(1))))) X (calc-pop-push num new))) X ((null stuff) X (if (> (length inc) 2) X (if (math-vectorp (nth 2 inc)) X (calc-comma) X (calc-pop-push 1 X (list 'incomplete 'vec (cdr (cdr inc))) X (list 'incomplete 'vec))))) X ((math-vectorp (car stuff)) X (calc-comma)) X ((eq (car-safe (car-safe (nth (+ num calc-stack-top) X calc-stack))) 'incomplete) X (calc-end-vector) X (calc-comma) X (let ((calc-algebraic-mode nil)) X (calc-begin-vector))) X ((or (= (length inc) 2) X (math-vectorp (nth 2 inc))) X (calc-pop-push num X (append inc (list (cons 'vec stuff))) X (list 'incomplete 'vec))) X (t X (calc-pop-push num X (list 'incomplete 'vec X (cons 'vec (append (cdr (cdr inc)) stuff))) X (list 'incomplete 'vec))))))) X) X X(defun calc-dots () X "Separate parts of an interval form during entry with a \"..\" symbol." X (interactive) X (calc-wrapper X (let ((num (calc-find-first-incomplete X (nthcdr calc-stack-top calc-stack) 1))) X (if (= num 0) X (error "Not entering an interval form")) X (let* ((inc (calc-top num)) X (stuff (calc-top-list (1- num))) X (new (append inc stuff))) X (if (not (eq (nth 1 new) 'intv)) X (setq new (append '(incomplete intv) X (if (eq (nth 1 new) 'vec) '(2) '(0)) X (cdr (cdr new))))) X (if (and (null stuff) X (or (eq (nth 1 inc) 'vec) X (< (length new) 5))) X (setq new (append new X (if (= (length new) 2) X '(0) X (nthcdr (1- (length new)) new))))) X (if (> (length new) 5) X (error "Too many components in interval form")) X (calc-pop-push num new)))) X) X X(defun calc-find-first-incomplete (stack n) X (cond ((null stack) X 0) X ((eq (car-safe (car-safe (car stack))) 'incomplete) X n) X (t X (calc-find-first-incomplete (cdr stack) (1+ n)))) X) X X X X X;;; Undo. X X(defun calc-undo (n) X "Undo the most recent operation in the Calculator. XWith a numeric prefix argument, undo the last N operations. XWith a negative argument, same as calc-redo. XWith a zero argument, same as calc-last-x." X (interactive "p") X (and calc-executing-macro X (error "Use C-x e, not K, to run a keyboard macro that uses Undo.")) X (if (<= n 0) X (if (< n 0) X (calc-redo (- n)) X (calc-last-x 1)) X (calc-wrapper X (if (null (nthcdr (1- n) calc-undo-list)) X (error "No further undo information available")) X (setq calc-undo-list X (prog1 X (nthcdr n calc-undo-list) X (let ((saved-stack-top calc-stack-top)) X (let ((calc-stack-top 0)) X (calc-handle-undos calc-undo-list n)) X (setq calc-stack-top saved-stack-top)))) X (message "Undo!"))) X) X X(defun calc-handle-undos (cl n) X (if (> n 0) X (progn X (let ((old-redo calc-redo-list)) X (setq calc-undo-list nil) X (calc-handle-undo (car cl)) X (setq calc-redo-list (append calc-undo-list old-redo))) X (calc-handle-undos (cdr cl) (1- n)))) X) X X(defun calc-handle-undo (list) X (and list X (let ((action (car list))) X (cond X ((eq (car action) 'push) X (calc-pop-stack 1 (nth 1 action))) X ((eq (car action) 'pop) X (calc-push-list (nth 2 action) (nth 1 action))) X ((eq (car action) 'set) X (calc-record-undo (list 'set (nth 1 action) X (symbol-value (nth 1 action)))) X (set (nth 1 action) (nth 2 action))) X ((eq (car action) 'store) X (let ((v (intern (nth 1 action)))) X (calc-record-undo (list 'store (nth 1 action) X (and (boundp v) (symbol-value v)))) X (if (y-or-n-p (format "Un-store variable %s? " (nth 1 action))) X (if (nth 2 action) X (set v (nth 2 action)) X (makunbound v))))) X ((eq (car action) 'eval) X (calc-record-undo (append (list 'eval (nth 2 action) (nth 1 action)) X (cdr (cdr (cdr action))))) X (apply (nth 1 action) (cdr (cdr (cdr action)))))) X (calc-handle-undo (cdr list)))) X) X X(defun calc-redo (n) X "Redo a command which was just inadvertently undone." X (interactive "p") X (and calc-executing-macro X (error "Use C-x e, not K, to run a keyboard macro that uses Redo.")) X (if (< n 0) X (calc-undo (- n)) X (calc-wrapper X (if (null (nthcdr (1- n) calc-redo-list)) X (error "Unable to redo")) X (setq calc-redo-list X (prog1 X (nthcdr n calc-redo-list) X (let ((saved-stack-top calc-stack-top)) X (let ((calc-stack-top 0)) X (calc-handle-redos calc-redo-list n)) X (setq calc-stack-top saved-stack-top)))) X (message "Redo!"))) X) X X(defun calc-handle-redos (cl n) X (if (> n 0) X (progn X (let ((old-undo calc-undo-list)) X (setq calc-undo-list nil) X (calc-handle-undo (car cl)) X (setq calc-undo-list (append calc-undo-list old-undo))) X (calc-handle-redos (cdr cl) (1- n)))) X) X X(defun calc-last-x (n) X "Restore the arguments to the last command, without removing its result. XWith a numeric prefix argument, restore the arguments of the Nth last Xcommand which popped things from the stack." X (interactive "p") X (and calc-executing-macro X (error "Use C-x e, not K, to run a keyboard macro that uses Last X.")) X (calc-wrapper X (let ((urec (calc-find-last-x calc-undo-list n))) X (if urec X (calc-handle-last-x urec) X (error "Not enough undo information available")))) X) X X(defun calc-handle-last-x (list) X (and list X (let ((action (car list))) X (if (eq (car action) 'pop) X (calc-pop-push-record-list 0 "lstx" X (delq 'top-of-stack (nth 2 action)))) X (calc-handle-last-x (cdr list)))) X) X X(defun calc-find-last-x (ul n) X (and ul X (if (calc-undo-does-pushes (car ul)) X (if (<= n 1) X (car ul) X (calc-find-last-x (cdr ul) (1- n))) X (calc-find-last-x (cdr ul) n))) X) X X(defun calc-undo-does-pushes (list) X (and list X (or (eq (car (car list)) 'pop) X (calc-undo-does-pushes (cdr list)))) X) X X X X;;; Arithmetic. X X(defun calc-min (arg) X "Compute the minimum of the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "min" 'calcFunc-min arg)) X) X X(defun calc-max (arg) X "Compute the maximum of the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "max" 'calcFunc-max arg)) X) X X(defun calc-abs (arg) X "Compute the absolute value of the top element of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "abs" 'calcFunc-abs arg)) X) X X(defun calc-sqrt (arg) X "Take the square root of the top element of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (if (calc-is-inverse) X (calc-unary-op "^2" 'calcFunc-sqr arg) X (calc-unary-op "sqrt" 'calcFunc-sqrt arg))) X) X X(defun calc-idiv (arg) X "Compute the integer quotient of the top two elements of the stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "\\" 'calcFunc-idiv arg 1)) X) X X(defun calc-fdiv (arg) X "Compute the quotient (in fraction form) of the top two elements of the stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op ":" 'calcFunc-fdiv arg 1)) X) X X(defun calc-floor (arg) X "Truncate to an integer (toward minus infinity) the top element of the stack. XWith Inverse flag, truncates toward plus infinity. XWith Hyperbolic flag, represent result in floating-point." X (interactive "P") X (calc-slow-wrapper X (if (calc-is-inverse) X (if (calc-is-hyperbolic) X (calc-unary-op "ceil" 'calcFunc-fceil arg) X (calc-unary-op "ceil" 'calcFunc-ceil arg)) X (if (calc-is-hyperbolic) X (calc-unary-op "flor" 'calcFunc-ffloor arg) X (calc-unary-op "flor" 'calcFunc-floor arg)))) SHAR_EOF echo "End of part 3" echo "File calc-ext.el is continued in part 4" echo "4" > s2_seq_.tmp exit 0